home *** CD-ROM | disk | FTP | other *** search
/ Experimental BBS Explossion 3 / Experimental BBS Explossion III.iso / pascal / tvtool2.zip / TVTYPE.PAS < prev    next >
Pascal/Delphi Source File  |  1993-07-20  |  8KB  |  78 lines
  1. {*
  2. *
  3. *   Copyright (c) 1992,93 by Richard W. Hansen
  4. *
  5. *   This source code will compile.
  6. *   Full source code available to registered users.
  7. *
  8. *}
  9. (* This file was mangled by Mangler 1.10 (c) Copyright 1993 by Berend de Boer *)
  10.  UNIT TVTYPE ;{$B+} {$X+} {$V-} {$I TVDEFS.INC} INTERFACE USES DOS , OBJECTS ;CONST DATESLASH :CHAR ='/';
  11. CONST BASEYEAR :WORD =1900 ;TYPE TBXFRAMEARRAY =ARRAY [ 1 .. 8 ]  OF CHAR ;PBXCHARARRAY =^TBXCHARARRAY ;
  12. TBXCHARARRAY =ARRAY [ 0 .. $FFE0 ]  OF CHAR ;PBXBYTEARRAY =^TBXBYTEARRAY ;TBXBYTEARRAY =ARRAY [ 0 .. $FFE0 ]  OF BYTE ;
  13. TBXCHARSET =SET  OF CHAR ;TBXBYTESET =SET  OF BYTE ;TBXLONG =RECORD LOW , HIGH :WORD ;END ;PBXITEMREC =^TBXITEMREC ;
  14. TBXITEMREC =RECORD OWNER , ITEM :POINTER ;END ;TBXDATEST =STRING [ 12 ] ;TBXDATEREC =RECORD DAY :BYTE ;MONTH :BYTE ;
  15. YEAR :WORD ;END ;PBXDATE =^TBXDATE ;TBXDATE =OBJECT (TOBJECT)DAY :BYTE ;MONTH :BYTE ;YEAR :WORD ;CONSTRUCTOR INIT
  16. (D :BYTE ;M :BYTE ;Y :WORD );CONSTRUCTOR LOAD (VAR S :TSTREAM );FUNCTION COMPARE (VAR ADATE :PBXDATE ):INTEGER ;
  17. FUNCTION DATESTRING (PICTURE :TBXDATEST ):TBXDATEST ;FUNCTION DAYSINMONTH :WORD ;PROCEDURE EXTRACTDATE
  18. (PICTURE :TBXDATEST ;ADATEST :TBXDATEST );PROCEDURE GETDATA (VAR REC );FUNCTION GETDAY :BYTE ;FUNCTION GETMONTH :BYTE ;
  19. FUNCTION GETYEAR :WORD ;FUNCTION LEAPYEAR :BOOLEAN ;PROCEDURE SETDATA (VAR REC );PROCEDURE SETDAY (D :BYTE );
  20. PROCEDURE SETMONTH (M :BYTE );PROCEDURE SETTODAY ;PROCEDURE SETYEAR (Y :WORD );PROCEDURE STORE (VAR S :TSTREAM );
  21. FUNCTION VALID :BOOLEAN ;VIRTUAL;PRIVATE FUNCTION FOURDIGITYEAR (Y :WORD ):WORD ;END ;CONST MONTHSTRING :ARRAY [ 1 .. 12
  22. ]  OF STRING [ 9 ] =('January', 'February', 'March', 'April', 'May', 'June', 'July', 'August', 'September', 'October',
  23. 'November', 'December');CONST DAYSTRING :ARRAY [ 1 .. 7 ]  OF STRING [ 9 ] =('Sunday', 'Monday', 'Tuesday', 'Wednesday',
  24. 'Thursday', 'Friday', 'Saturday');FUNCTION ISLEAPYEAR (YEAR :WORD ):BOOLEAN ;FUNCTION DAYSINMONTH
  25. (DATE :TBXDATEREC ):WORD ;FUNCTION COMPAREDATE (DATE1 :TBXDATEREC ;DATE2 :TBXDATEREC ):INTEGER ;
  26. FUNCTION DATETODATESTRING (DATE :TBXDATEREC ;PICTURE :TBXDATEST ):TBXDATEST ;PROCEDURE EXTRACTDATEFROMSTRING
  27. (VAR DATE :TBXDATEREC ;PICTURE :TBXDATEST ;ADATEST :TBXDATEST );PROCEDURE REGISTERTVTYPE ;
  28. CONST RBXDATE :TSTREAMREC =(OBJTYPE :5050 ;VMTLINK :OFS (TYPEOF (TBXDATE )^);LOAD :@ TBXDATE . LOAD ;STORE :@ TBXDATE .
  29. STORE );IMPLEMENTATION FUNCTION ISLEAPYEAR (YEAR:WORD):BOOLEAN ;BEGIN ISLEAPYEAR := (YEAR MOD 4 =0 )AND (YEAR MOD 4000 <>
  30. 0 )AND ((YEAR MOD 100 <> 0 )OR (YEAR MOD 400 =0 ));END ;FUNCTION DAYSINMONTH (DATE:TBXDATEREC):WORD ;
  31. BEGIN CASE DATE.MONTH  OF 1 , 3 , 5 , 7 , 8 , 10 , 12 :DAYSINMONTH := 31 ;2 :IF ISLEAPYEAR (DATE.YEAR )THEN DAYSINMONTH
  32. := 29 ELSE DAYSINMONTH := 28 ;4 , 6 , 9 , 11 :DAYSINMONTH := 30 ;ELSE DAYSINMONTH := 0 ;END ;END ;FUNCTION COMPAREDATE
  33. (DATE1:TBXDATEREC;DATE2:TBXDATEREC):INTEGER ;BEGIN IF (DATE1.YEAR < DATE2.YEAR )THEN COMPAREDATE := - 1 ELSE IF
  34. (DATE1.YEAR > DATE2.YEAR )THEN COMPAREDATE := 1 ELSE IF (DATE1.MONTH < DATE2.MONTH )THEN COMPAREDATE := - 1 ELSE IF
  35. (DATE1.MONTH > DATE2.MONTH )THEN COMPAREDATE := 1 ELSE IF (DATE1.DAY < DATE2.DAY )THEN COMPAREDATE := - 1 ELSE IF
  36. (DATE1.DAY > DATE2.DAY )THEN COMPAREDATE := 1 ELSE COMPAREDATE := 0 ;END ;FUNCTION DATETODATESTRING (DATE:TBXDATEREC;
  37. PICTURE:TBXDATEST):TBXDATEST ;PROCEDURE OI101O00I1I1 (O10lIlll:CHAR;OO0O:WORD;VAR OI11I10II10:STRING );
  38. VAR OIlO,OIll:BYTE;OO1O:STRING [ 4 ] ;BEGIN OIlO := POS (O10lIlll , OI11I10II10 );O10lIlll := UPCASE (O10lIlll );IF (OIlO
  39. =0 )THEN BEGIN OIlO := POS (O10lIlll , OI11I10II10 );IF (OIlO =0 )THEN EXIT ;END ;WHILE (OIlO < LENGTH (OI11I10II10 ))AND
  40. (UPCASE (OI11I10II10 [ OIlO + 1 ] )=O10lIlll ) DO INC (OIlO );STR (OO0O :4 , OO1O );OIll := 4 ;WHILE (OIlO > 0 )AND
  41. (UPCASE (OI11I10II10 [ OIlO ] )=O10lIlll ) DO BEGIN IF (OIll > 0 )AND (OO1O [ OIll ] <> ' ')THEN BEGIN OI11I10II10 [ OIlO
  42. ] := OO1O [ OIll ] ;DEC (OIll );END ELSE IF (OI11I10II10 [ OIlO ] < 'a')THEN BEGIN OI11I10II10 [ OIlO ] := ' ';END ELSE
  43. BEGIN OI11I10II10 [ OIlO ] := '0';END ;DEC (OIlO );END ;END ;VAR OIlO:BYTE;BEGIN OI101O00I1I1 ('d', DATE.DAY , PICTURE );
  44. OI101O00I1I1 ('m', DATE.MONTH , PICTURE );OI101O00I1I1 ('y', DATE.YEAR , PICTURE );FOR OIlO := 1 TO LENGTH (PICTURE
  45. ) DO IF PICTURE [ OIlO ] ='/'THEN PICTURE [ OIlO ] := DATESLASH ;DATETODATESTRING := PICTURE ;END ;
  46. PROCEDURE EXTRACTDATEFROMSTRING (VAR DATE:TBXDATEREC;PICTURE:TBXDATEST;ADATEST:TBXDATEST);PROCEDURE Ol1lI0011O
  47. (O10lIlll:CHAR;VAR OI11I10II10:STRING ;VAR O11lIOII:STRING ;VAR OO0O:WORD);VAR OIlO,OIll:INTEGER;OIOI100IlI0:TBXDATEST;
  48. OI0ll01lOOOl:WORD;BEGIN OO0O := 0 ;OIlO := POS (O10lIlll , OI11I10II10 );O10lIlll := UPCASE (O10lIlll );OIll := POS
  49. (O10lIlll , OI11I10II10 );IF (OIlO =0 )OR ((OIll <> 0 )AND (OIll < OIlO ))THEN OIlO := OIll ;IF (OIlO =0 )THEN EXIT ;
  50. OIll := 0 ;WHILE (UPCASE (OI11I10II10 [ OIlO ] )=O10lIlll )AND (OIlO <= LENGTH (O11lIOII )) DO BEGIN IF O11lIOII [ OIlO ]
  51. <> ' 'THEN BEGIN INC (OIll );OIOI100IlI0 [ OIll ] := O11lIOII [ OIlO ] ;END ;INC (OIlO );END ;BYTE (OIOI100IlI0 [ 0 ] ):=
  52. OIll ;VAL (OIOI100IlI0 , OO0O , OI0ll01lOOOl );IF (OI0ll01lOOOl <> 0 )THEN OO0O := 0 ;END ;VAR OIOO,OO0I,OOIl:WORD;
  53. BEGIN Ol1lI0011O ('m', PICTURE , ADATEST , OO0I );Ol1lI0011O ('d', PICTURE , ADATEST , OIOO );Ol1lI0011O ('y', PICTURE ,
  54. ADATEST , OOIl );DATE.DAY := OIOO ;DATE.MONTH := OO0I ;DATE.YEAR := OOIl ;END ;CONSTRUCTOR TBXDATE.INIT (D:BYTE;M:BYTE;
  55. Y:WORD);BEGIN INHERITED INIT;DAY := D ;MONTH := M ;YEAR := Y ;END ;CONSTRUCTOR TBXDATE.LOAD (VAR S:TSTREAM);
  56. BEGIN S.WRITE (DAY , SIZEOF (BYTE ));S.WRITE (MONTH , SIZEOF (BYTE ));S.WRITE (YEAR , SIZEOF (WORD ));END ;
  57. FUNCTION TBXDATE.COMPARE (VAR ADATE:PBXDATE):INTEGER ;VAR OI0ll1OI00IO:TBXDATEREC;OOlIl0I0Il0l:TBXDATEREC;
  58. BEGIN OI0ll1OI00IO.DAY := DAY ;OI0ll1OI00IO.MONTH := MONTH ;OI0ll1OI00IO.YEAR := YEAR ;OOlIl0I0Il0l.DAY := ADATE ^. DAY ;
  59. OOlIl0I0Il0l.MONTH := ADATE ^. MONTH ;OOlIl0I0Il0l.YEAR := ADATE ^. YEAR ;COMPARE := COMPAREDATE (OI0ll1OI00IO ,
  60. OOlIl0I0Il0l );END ;FUNCTION TBXDATE.DATESTRING (PICTURE:TBXDATEST):TBXDATEST ;VAR OI1III11OOII:TBXDATEREC;
  61. BEGIN OI1III11OOII.DAY := DAY ;OI1III11OOII.MONTH := MONTH ;OI1III11OOII.YEAR := YEAR ;DATESTRING := DATETODATESTRING
  62. (OI1III11OOII , PICTURE );END ;FUNCTION TBXDATE.DAYSINMONTH :WORD ;VAR OI1III11OOII:TBXDATEREC;BEGIN OI1III11OOII.DAY :=
  63. DAY ;OI1III11OOII.MONTH := MONTH ;OI1III11OOII.YEAR := FOURDIGITYEAR (YEAR );DAYSINMONTH := TVTYPE.DAYSINMONTH
  64. (OI1III11OOII );END ;PROCEDURE TBXDATE.EXTRACTDATE (PICTURE:TBXDATEST;ADATEST:TBXDATEST);VAR OI1III11OOII:TBXDATEREC;
  65. BEGIN EXTRACTDATEFROMSTRING (OI1III11OOII , PICTURE , ADATEST );DAY := OI1III11OOII.DAY ;MONTH := OI1III11OOII.MONTH ;
  66. YEAR := OI1III11OOII.YEAR ;END ;FUNCTION TBXDATE.FOURDIGITYEAR (Y:WORD):WORD ;BEGIN IF (Y < 100 )THEN FOURDIGITYEAR := Y
  67. + BASEYEAR ELSE FOURDIGITYEAR := Y ;END ;PROCEDURE TBXDATE.GETDATA (VAR REC);BEGIN TBXDATEREC (REC ). YEAR := YEAR ;
  68. TBXDATEREC (REC ). MONTH := MONTH ;TBXDATEREC (REC ). DAY := DAY ;END ;FUNCTION TBXDATE.GETDAY :BYTE ;BEGIN GETDAY := DAY
  69. ;END ;FUNCTION TBXDATE.GETMONTH :BYTE ;BEGIN GETMONTH := MONTH ;END ;FUNCTION TBXDATE.GETYEAR :WORD ;BEGIN GETYEAR :=
  70. YEAR ;END ;FUNCTION TBXDATE.LEAPYEAR :BOOLEAN ;BEGIN LEAPYEAR := ISLEAPYEAR (YEAR );END ;PROCEDURE TBXDATE.SETDATA
  71. (VAR REC);BEGIN YEAR := TBXDATEREC (REC ). YEAR ;MONTH := TBXDATEREC (REC ). MONTH ;DAY := TBXDATEREC (REC ). DAY ;END ;
  72. PROCEDURE TBXDATE.SETDAY (D:BYTE);BEGIN DAY := D ;END ;PROCEDURE TBXDATE.SETMONTH (M:BYTE);BEGIN MONTH := M ;END ;
  73. PROCEDURE TBXDATE.SETTODAY ;VAR OIOO,OO0I,OOIl,O1I0OOO0:WORD;BEGIN DOS.GETDATE (OOIl , OO0I , OIOO , O1I0OOO0 );DAY :=
  74. OIOO ;MONTH := OO0I ;YEAR := OOIl ;END ;PROCEDURE TBXDATE.SETYEAR (Y:WORD);BEGIN YEAR := Y ;END ;PROCEDURE TBXDATE.STORE
  75. (VAR S:TSTREAM);BEGIN S.READ (DAY , SIZEOF (BYTE ));S.READ (MONTH , SIZEOF (BYTE ));S.READ (YEAR , SIZEOF (WORD ));END ;
  76. FUNCTION TBXDATE.VALID :BOOLEAN ;BEGIN VALID := (DAY <> 0 )AND (DAY <= DAYSINMONTH );END ;PROCEDURE REGISTERTVTYPE ;
  77. BEGIN REGISTERTYPE (RBXDATE );END ;END .
  78.